{-# OPTIONS_GHC -XTemplateHaskell -XNoMonomorphismRestriction #-}
module Data.Function.FliprTH(mkFliprs) where

import Language.Haskell.TH
import Control.Monad(guard, liftM2)
import Data.List(unfoldr, foldl')
import Data.Maybe(isNothing, fromJust)

{-
flipr2 = flipr1 . comp1 flipr1
comp2 = comp1 . comp1
flipr4 =  flipr2 . comp2 flipr2
{-# NOINLINE flipr4 #-}
comp4 = comp2 . comp2
{-# NOINLINE comp4 #-}
flipr8 =  flipr4 . comp4 flipr4
{-# NOINLINE flipr8 #-}
comp8 = comp4 . comp4
{-# NOINLINE comp8 #-}
-}

binList = reverse . unfoldr (\k -> guard (k > 0) >> return (uncurry (flip (,)) $ quotRem k 2))
   
mkFliprs :: Int -> [DecQ]
mkFliprs n 
    | n <= 1 = []
    | all (==0) xs = do
        let n2 = show (n `quot` 2)
        let [f1, c1, f2, c2] = liftM2 nameK [n `quot` 2, n] ["flipr", "comp"]
        mkFliprs (n-1) ++ [
                valD (varP f2) (normalB [| $(varE f1) . $(varE c1) $(varE f1) |]) [],
                pragInlD f2 $ inlineSpecNoPhase (n<3) False,
                valD (varP c2) (normalB [| $(varE c1) . $(varE c1) |]) [],
                pragInlD c2 $ inlineSpecNoPhase (n<3) False
            ] 
    | otherwise = mkFliprs (n-1) ++ [        
        valD (varP $ nameK n "flipr") (normalB $ (\(k, Just exp) -> [| $(exp) $(varE $ nameK (2^k) "flipr") |]) $ 
            foldl' (\(k, exp) x -> (k + 1, if x == 0 then exp else 
                    let exp' = [| ($(varE $ nameK (2^k) "flipr").) . $(varE $ nameK (2^k) "comp") |] in
                        if isNothing exp then Just exp' else Just [| $(exp') . $(fromJust exp)|])
                ) (0, Nothing) xs) []
        ]
    where
        xs = tail $ binList n
        nameK = (mkName.) . flip (++) . show